Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue60/COMThrd/STAThread.pas

Pascal/Delphi Source File | 2000-06-07 | 6.3 KB | 225 lines

unit STAThread;

interface

uses
  ComObj, ActiveX, Classes, Windows;

type
  TComObjectFactory2 = class(TComObjectFactory, IClassFactory)
  protected
    //Create the COM object in a separate thread
    function CreateInstance(const UnkOuter: IUnknown;
      const IID: TGUID; out Obj): HResult; stdcall;
  end;

  TTypedComObjectFactory2 = class(TTypedComObjectFactory, IClassFactory)
  protected
    //Create the COM object in a separate thread
    function CreateInstance(const UnkOuter: IUnknown;
      const IID: TGUID; out Obj): HResult; stdcall;
  end;

  TAutoObjectFactory2 = class(TAutoObjectFactory, IClassFactory)
  protected
    //Create the Automation object in a separate thread
    function CreateInstance(const UnkOuter: IUnknown;
      const IID: TGUID; out Obj): HResult; stdcall;
  end;

  TApartmentThread = class(TThread)
  private
    FFactory: IClassFactory2;
    FUnkOuter: IUnknown;
    FIID: TGuid;
    FSemaphore: THandle;
    FStream: Pointer;
    FCreateResult: HResult;
  protected
    procedure Execute; override;
  public
    constructor Create(Factory: IClassFactory2;
      UnkOuter: IUnknown; IID: TGuid);
    destructor Destroy; override;
    property Semaphore: THandle read FSemaphore;
    property CreateResult: HResult read FCreateResult;
    property ObjStream: Pointer read FStream;
  end;

implementation

uses
  SysUtils;

{ TComObjectFactory2 }

function TComObjectFactory2.CreateInstance(const UnkOuter: IUnknown;
  const IID: TGUID; out Obj): HResult;
begin
  //Verify we are not an in-proc server and that the object is STA-ready
  if not IsLibrary and (ThreadingModel = tmApartment) then
  begin
    LockServer(True);
    try
      //Create thread
      with TApartmentThread.Create(Self, UnkOuter, IID) do
      begin
        //Wait for thread to create the COM object
        if WaitForSingleObject(Semaphore, INFINITE) = WAIT_OBJECT_0 then
        begin
          Result := CreateResult;
          if Result <> S_OK then Exit;
          //If all is well, unmarshal the interface from the stream
          Result := CoGetInterfaceAndReleaseStream(IStream(ObjStream), IID, Obj);
        end
        else
          Result := E_FAIL
      end
    finally
      LockServer(False)
    end
  end
  else
    //In-proc servers and non-STA objects get created as normal
    Result := inherited CreateInstance(UnkOuter, IID, Obj);
end;

{ TTypedComObjectFactory2 }

function TTypedComObjectFactory2.CreateInstance(const UnkOuter: IUnknown;
  const IID: TGUID; out Obj): HResult;
begin
  //Verify we are not an in-proc server and that the object is STA-ready
  if not IsLibrary and (ThreadingModel = tmApartment) then
  begin
    LockServer(True);
    try
      //Create thread
      with TApartmentThread.Create(Self, UnkOuter, IID) do
      begin
        //Wait for thread to create the COM object
        if WaitForSingleObject(Semaphore, INFINITE) = WAIT_OBJECT_0 then
        begin
          Result := CreateResult;
          if Result <> S_OK then Exit;
          //If all is well, unmarshal the interface from the stream
          Result := CoGetInterfaceAndReleaseStream(IStream(ObjStream), IID, Obj);
        end
        else
          Result := E_FAIL
      end
    finally
      LockServer(False)
    end
  end
  else
    //In-proc servers and non-STA objects get created as normal
    Result := inherited CreateInstance(UnkOuter, IID, Obj);
end;

{ TAutoObjectFactory2 }

function TAutoObjectFactory2.CreateInstance(const UnkOuter: IUnknown;
  const IID: TGUID; out Obj): HResult;
begin
  //Verify we are not an in-proc server and that the object is STA-ready
  if not IsLibrary and (ThreadingModel = tmApartment) then
  begin
    LockServer(True);
    try
      //Create thread
      with TApartmentThread.Create(Self, UnkOuter, IID) do
      begin
        //Wait for thread to create the COM object
        if WaitForSingleObject(Semaphore, INFINITE) = WAIT_OBJECT_0 then
        begin
          Result := CreateResult;
          if Result <> S_OK then Exit;
          //If all is well, unmarshal the interface from the stream
          Result := CoGetInterfaceAndReleaseStream(IStream(ObjStream), IID, Obj);
        end
        else
          Result := E_FAIL
      end
    finally
      LockServer(False)
    end
  end
  else
    //In-proc servers and non-STA objects get created as normal
    Result := inherited CreateInstance(UnkOuter, IID, Obj);
end;

{ TApartmentThread }

constructor TApartmentThread.Create(Factory: IClassFactory2;
  UnkOuter: IUnknown; IID: TGuid);
begin
  inherited Create(True);
  FFactory := Factory;
  FUnkOuter := UnkOuter;
  FIID := IID;
  //Create the synchronisation device
  FSemaphore := CreateSemaphore(nil, 0, 1, nil);
  FreeOnTerminate := True;
  //After setting all the thread attributes, let this thread start
  Resume
end;

destructor TApartmentThread.Destroy;
begin
  CloseHandle(FSemaphore);
  inherited Destroy;
end;

procedure TApartmentThread.Execute;
var
  Msg: TMsg;
  Unk: IUnknown;

  function FinalRefCount: Integer;
  begin
    //Return 0 on Win95 (Windows version 4.0)
    if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) and
       (Win32MajorVersion = 4) and (Win32MinorVersion = 0) then
      Result := 0
    else
      Result := 1
  end;

begin
  try
    //Enter STA
    CoInitialize(nil);
    try
      //Create object
      FCreateResult := FFactory.CreateInstanceLic(FUnkOuter, nil, FIID, '', Unk);
      FUnkOuter := nil;
      FFactory := nil;
      //Marshal interface reference into stream
      if FCreateResult = S_OK then
        CoMarshalInterThreadInterfaceInStream(FIID, Unk, IStream(FStream));
      //Allow factory to read the interface reference
      ReleaseSemaphore(FSemaphore, 1, nil);
      if FCreateResult = S_OK then
        //Start the message pump
        while GetMessage(Msg, 0, 0, 0) do
        begin
          DispatchMessage(Msg);
          //See if the only connection to this object is ours
          //If it is, then this thread's work is done
          Unk._AddRef;
          if Unk._Release = FinalRefCount then
            Break;
        end;
    finally
      Unk := nil;
      //Leave the STA
      CoUninitialize;
    end;
  except
    // No exceptions should go unhandled
  end;
end;

end.